Extrem(ist +) Fightin’ Words

practicing

load libraries

load the FW functions

### CODE DIRECTLY FROM: https://burtmonroe.github.io/TextAsDataCourse/Tutorials/TADA-FightinWords.nb.html#

fwgroups <- function(dtm, groups, pair = NULL, weights = rep(1,nrow(dtm)), k.prior = .1) {
  
  weights[is.na(weights)] <- 0
  
  weights <- weights/mean(weights)
  
  zero.doc <- rowSums(dtm)==0 | weights==0
  zero.term <- colSums(dtm[!zero.doc,])==0
  
  dtm.nz <- apply(dtm[!zero.doc,!zero.term],2,"*", weights[!zero.doc])
  
  g.prior <- tcrossprod(rowSums(dtm.nz),colSums(dtm.nz))/sum(dtm.nz)
  
  # 
  
  g.posterior <- as.matrix(dtm.nz + k.prior*g.prior)
  
  groups <- groups[!zero.doc]
  groups <- droplevels(groups)
  
  g.adtm <- as.matrix(aggregate(x=g.posterior,by=list(groups=groups),FUN=sum)[,-1])
  rownames(g.adtm) <- levels(groups)
  
  g.ladtm <- log(g.adtm)
  
  g.delta <- t(scale( t(scale(g.ladtm, center=T, scale=F)), center=T, scale=F))
  
  g.adtm_w <- -sweep(g.adtm,1,rowSums(g.adtm)) # terms not w spoken by k
  g.adtm_k <- -sweep(g.adtm,2,colSums(g.adtm)) # w spoken by groups other than k
  g.adtm_kw <- sum(g.adtm) - g.adtm_w - g.adtm_k - g.adtm # total terms not w or k 
  
  g.se <- sqrt(1/g.adtm + 1/g.adtm_w + 1/g.adtm_k + 1/g.adtm_kw)
  
  g.zeta <- g.delta/g.se
  
  g.counts <- as.matrix(aggregate(x=dtm.nz, by = list(groups=groups), FUN=sum)[,-1])
  
  if (!is.null(pair)) {
    pr.delta <- t(scale( t(scale(g.ladtm[pair,], center = T, scale =F)), center=T, scale=F))
    pr.adtm_w <- -sweep(g.adtm[pair,],1,rowSums(g.adtm[pair,]))
    pr.adtm_k <- -sweep(g.adtm[pair,],2,colSums(g.adtm[pair,])) # w spoken by groups other than k
    pr.adtm_kw <- sum(g.adtm[pair,]) - pr.adtm_w - pr.adtm_k - g.adtm[pair,] # total terms not w or k
    pr.se <- sqrt(1/g.adtm[pair,] + 1/pr.adtm_w + 1/pr.adtm_k + 1/pr.adtm_kw)
    pr.zeta <- pr.delta/pr.se
    
    return(list(zeta=pr.zeta[1,], delta=pr.delta[1,],se=pr.se[1,], counts = colSums(dtm.nz), acounts = colSums(g.adtm)))
  } else {
    return(list(zeta=g.zeta,delta=g.delta,se=g.se,counts=g.counts,acounts=g.adtm))
  }
}

############## FIGHTIN' WORDS PLOTTING FUNCTION

# helper function
makeTransparent<-function(someColor, alpha=100)
{
  newColor<-col2rgb(someColor)
  apply(newColor, 2, function(curcoldata){rgb(red=curcoldata[1], green=curcoldata[2],
                                              blue=curcoldata[3],alpha=alpha, maxColorValue=255)})
}

fw.ggplot.groups <- function(fw.ch, groups.use = as.factor(rownames(fw.ch$zeta)), max.words = 50, max.countrank = 400, colorpalette=rep("black",length(groups.use)), sizescale=2, title="Comparison of Terms by Groups", subtitle = "", caption = "Group-specific terms are ordered by Fightin' Words statistic (Monroe, et al. 2008)") {
  if (is.null(dim(fw.ch$zeta))) {## two-group fw object consists of vectors, not matrices
    zetarankmat <- cbind(rank(-fw.ch$zeta),rank(fw.ch$zeta))
    colnames(zetarankmat) <- groups.use
    countrank <- rank(-(fw.ch$counts))
  } else {
    zetarankmat <- apply(-fw.ch$zeta[groups.use,],1,rank)
    countrank <- rank(-colSums(fw.ch$counts))
  }
  wideplotmat <- as_tibble(cbind(zetarankmat,countrank=countrank))
  wideplotmat$term=names(countrank)
  #rankplot <- gather(wideplotmat, party, zetarank, 1:ncol(zetarankmat))
  rankplot <- gather(wideplotmat, groups.use, zetarank, 1:ncol(zetarankmat))
  rankplot$plotsize <- sizescale*(50/(rankplot$zetarank))^(1/4)
  rankplot <- rankplot[rankplot$zetarank < max.words + 1 & rankplot$countrank<max.countrank+1,]
  rankplot$groups.use <- factor(rankplot$groups.use,levels=groups.use)
  
  p <- ggplot(rankplot, aes((nrow(rankplot)-countrank)^1, -(zetarank^1), colour=groups.use)) + 
    geom_point(show.legend=F,size=sizescale/2) + 
    theme_classic() +
    theme(axis.ticks=element_blank(), axis.text=element_blank() ) +
    ylim(-max.words,40) +
    facet_grid(groups.use ~ .) +
    geom_text_repel(aes(label = term), size = rankplot$plotsize, point.padding=.05,
                    box.padding = unit(0.20, "lines"), show.legend=F, max.overlaps = Inf) +
    scale_colour_manual(values = alpha(colorpalette, .7)) + 
#    labs(x="Terms used more frequently overall →", y="Terms used more frequently by group →",  title=title, subtitle=subtitle , caption = caption) 
    labs(x=paste("Terms used more frequently overall -->"), y=paste("Terms used more frequently by group -->"),  title=title, subtitle=subtitle , caption = caption) 
  
}

options(ggrepel.max.overlaps = Inf)

fw.keys <- function(fw.ch,n.keys=10) {
  n.groups <- nrow(fw.ch$zeta)
  keys <- matrix("",n.keys,n.groups)
  colnames(keys) <- rownames(fw.ch$zeta)
  
  for (g in 1:n.groups) {
    keys[,g] <- names(sort(fw.ch$zeta[g,],dec=T)[1:n.keys])
  }
  keys
}

Compare NYT Before and After “extremist” and other query terms

Load and clean the data

• to string & lower text
• pivot to long format
• apply text_cleaner to one column “context.text”

text_cleaner<-function(corpus){
  tempcorpus<-Corpus(VectorSource(corpus))
  tempcorpus<-tm_map(tempcorpus,
                    removePunctuation)
  tempcorpus<-tm_map(tempcorpus,
                    stripWhitespace)
  tempcorpus<-tm_map(tempcorpus,
                    removeNumbers)
  tempcorpus<-tm_map(tempcorpus,
                     removeWords, stopwords("english"))
  tempcorpus<-tm_map(tempcorpus, 
                    stemDocument)
  return(tempcorpus)
}

transformation drops documentstransformation drops documentstransformation drops documentstransformation drops documentstransformation drops documents

Calculate FW.

[1] 29844 14891
Document-feature matrix of: 6 documents, 14,891 features (100.0% sparse).
       features
docs    us struggl uptick american plot attack past month last week
  text1  1       1      1        1    1      0    0     0    0    0
  text2  0       0      0        0    0      1    1     1    1    1
  text3  0       0      0        0    0      0    0     0    0    0
  text4  0       0      0        0    0      0    0     0    0    0
  text5  0       0      0        0    0      0    0     0    0    0
  text6  0       0      0        0    0      0    0     0    0    0
[ reached max_nfeat ... 14,881 more features ]

Removing features occurring: 
  - fewer than 4 times: 10,569
  Total features removed: 10,569 (71.1%).

[1] 29844  4289

Get and show the top words per group by zeta.

library(knitr)
fwkeys.extrem <- fw.keys(fw.extrem, n.keys=20)
kable(fwkeys.extrem)

Context.after	Context.before
group	islam
hussein	palestinian
attack	war
parti	iraqi
elect	suspect
leader	crack
jihad	jemaah
milit	crackdown
movement	main
said	alleg
guerrilla	support
network	evid
regim	albanian
armi	sept
politician	prodemocraci
organ	muslim
outsid	megawati
univers	battl
bomb	prevent
rocket	kosovo

Plot: Before in Blue, After in Red

p.fw.extrem <- fw.ggplot.groups(fw.extrem,sizescale=4,max.words=200,
                                max.countrank=400,colorpalette=c("red","blue"))
p.fw.extrem

Calculate by query item/search term

extrem_NYT.dfm.long$Query.item <- as.factor(extrem_NYT.dfm.long$Query.item)

top_n <-as.data.frame(sort(table(extrem_NYT.dfm.long$Query.item), decreasing = TRUE)[1:5]) 
dim(top_n)

[1] 5 2

colnames(top_n) <- c('term', 'Freq')
top_n

extrem_dtm_topn <- convert(e, to='data.frame')
extrem_dtm_topn$Number.of.hit <- extrem_NYT.dfm.long$Number.of.hit

topn_terms <- extrem_NYT.dfm.long %>%
      filter(Query.item %in% top_n$term)

extrem_dtm_topn_keep <- extrem_dtm_topn %>% 
    filter(Number.of.hit %in% topn_terms$Number.of.hit)

r <- sum(length(extrem_dtm_topn_keep))

extrem_dtm_topn_keep <- extrem_dtm_topn_keep[-c(1, r)]

fw.query_item <- fwgroups(extrem_dtm_topn_keep,groups = topn_terms$Query.item)
fwkeys.query_item <- fw.keys(fw.query_item, n.keys=15)
kable(fwkeys.query_item)

Islamic	militants	opposition	Saddam	terrorist
milit	islam	parti	hussein	attack
hama	palestinian	democrat	iraqi	organ
jihad	kill	leader	iraq	sept
group	isra	parliament	presid	unit
movement	suspect	elect	regim	state
extremist	gaza	vote	saddam	activ
front	israel	opposit	baghdad	alqaida
insurg	attack	lawmak	un	act
radic	kashmir	polit	kuwait	network
republ	taliban	main	captur	group
law	arafat	candid	war	laden
fundamentalist	forc	coalit	oust	bin
revolut	pakistani	conserv	weapon	suspect
somalia	fire	allianc	bush	connect
hardlin	pakistan	protest	us	financ

rm(r)
rm(extrem_dtm_topn)

p.fw.query_item <- fw.ggplot.groups(fw.query_item,sizescale=2,max.words=50,max.countrank=400)
p.fw.query_item

extrem_dtm_topn <- convert(e, to='data.frame')
extrem_dtm_topn$Number.of.hit <- extrem_NYT.dfm.long$Number.of.hit
extrem_dtm_topn$Context <- extrem_NYT.dfm.long$Context

topn_terms <- extrem_NYT.dfm.long %>%
      filter(Query.item %in% top_n$term)

extrem_dtm_topn_keep <- extrem_dtm_topn %>% 
    filter(Number.of.hit %in% topn_terms$Number.of.hit)

extrem_dtm_topn_keep_before <- extrem_dtm_topn_keep[grep("before",extrem_dtm_topn_keep$Context),]
extrem_dtm_topn_keep_after <- extrem_dtm_topn_keep[grep("after", extrem_dtm_topn_keep$Context),]

rr <-dim(topn_terms)[1]
r <- sum(length(extrem_dtm_topn_keep_before))
topn_terms_before <- topn_terms[seq(1,rr,2),]
topn_terms_after <- topn_terms[seq(2,rr,2),]

extrem_dtm_topn_keep_before <- extrem_dtm_topn_keep_before[-c(1, r-1, r)]
extrem_dtm_topn_keep_after <- extrem_dtm_topn_keep_after[-c(1, r-1, r)]

rm(rr)
rm(r)
rm(extrem_dtm_topn)

#############################################
fw.query_item_before <- fwgroups(extrem_dtm_topn_keep_before,groups = topn_terms_before$Query.item)
fwkeys.query_item_before <- fw.keys(fw.query_item_before, n.keys=15)
kable(fwkeys.query_item_before)

Islamic	militants	opposition	Saddam	terrorist
milit	islam	main	iraqi	sept
organ	palestinian	elect	presid	alqaida
strict	kill	polit	iraq	bin
radic	suspect	parliament	war	laden
somalia	attack	opposit	saddam	involv
hama	taliban	parti	oust	unit
secular	isra	minist	baghdad	suspect
hardlin	muslim	vote	fall	link
iran	gaza	democrat	bush	state
turkey	armi	prime	hussein	consid
extremist	troop	strong	captur	connect
malaysia	israel	percent	regim	appar
suprem	pakistan	despit	usl	osama
gaza	forc	poll	former	charg
fundamentalist	arafat	voic	death	list

p.fw.query_item_before <- fw.ggplot.groups(fw.query_item_before,sizescale=2,max.words=50,max.countrank=400,
                                           colorpalette = c('red', 'red','red','red','red'))
p.fw.query_item_before

#############################################
fw.query_item_after <- fwgroups(extrem_dtm_topn_keep_after,groups = topn_terms_after$Query.item)
fwkeys.query_item_after <- fw.keys(fw.query_item_after, n.keys=15)
kable(fwkeys.query_item_after)

Islamic	militants	opposition	Saddam	terrorist
milit	isra	parti	hussein	attack
group	israel	leader	regim	organ
jihad	kashmir	democrat	iraq	state
hama	gaza	vote	iraqi	unit
movement	palestinian	parliament	un	activ
law	kill	lawmak	weapon	group
insurg	attack	protest	saddam	act
extremist	region	elect	son	network
front	southern	candid	captur	bomb
revolut	fire	politician	kuwait	suspect
republ	rocket	coalit	mass	threat
court	pakistani	social	baghdad	financ
fundamentalist	fight	conserv	us	sept
news	border	win	resolut	link
agenc	area	opposit	palac	cell

p.fw.query_item_after <- fw.ggplot.groups(fw.query_item_after,sizescale=2,max.words=50,max.countrank=400,
                                           colorpalette = c('blue','blue','blue', 'blue','blue'))
p.fw.query_item_after

NA
NA

Calculate Parts of speech by before and after

Calculate FW and keys

### https://cran.r-project.org/web/packages/udpipe/vignettes/udpipe-usecase-postagging-lemmatisation.html

library(udpipe)

ud_model <- udpipe_download_model(language = "english")

ud_model <- udpipe_load_model(ud_model$file_model)

txt <-as.character(extrem_NYT.dfm.long$context.text)

x_udp <- udpipe_annotate(ud_model, x = txt, doc_id = seq_along(txt))
x <- as.data.frame(x_udp)

x$doc_id <-as.integer(x$doc_id)

x_odd.before <- x[x$doc_id %% 2 == 1,]
x_even.after <-x[x$doc_id %% 2 == 0, ]

A few barchart functions

Bar Charts from Functions Above

Cooccurences

Cooccurences (part 2)

Corrs <- function(df){
  df$id <- unique_identifier(df, fields = c("sentence_id", "doc_id"))
  dtm <- subset(df, upos %in% c("NOUN", "ADJ"))
  dtm <- document_term_frequencies(dtm, document = "id", term = "lemma")
  dtm <- document_term_matrix(dtm)
  dtm <- dtm_remove_lowfreq(dtm, minfreq = 5)
  termcorrelations <- dtm_cor(dtm)
  y <- as_cooccurrence(termcorrelations)
  y <- subset(y, term1 < term2 & abs(cooc) > 0.2)
  y <- y[order(abs(y$cooc), decreasing = TRUE), ]
  print(y[1:25,])
}


Corrs(x_odd.before)

Corrs(x_even.after)

home